home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / access / YALIB.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  56.7 KB  |  1,976 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.5
  6. C---------------------------------------------------------
  7. C---------------------------------------------------------
  8. C    TOOLPACK/1    Release: 2.5
  9. C---------------------------------------------------------
  10.  
  11.  
  12.  
  13.  
  14.  
  15.  
  16.  
  17.  
  18. C                                   parameter length
  19.  
  20.  
  21.  
  22.  
  23.  
  24.  
  25.  
  26.  
  27.  
  28. C following are for ZYCSDT (Canonicalise Symbol Data Types)
  29. C ----------------------------------------------------------------------
  30. C
  31. C       Z Y A D N X   -   Add a node next to this one
  32. C
  33. C       (Make N1 come next  to (i.e. after) N2).
  34. C
  35.  
  36.         SUBROUTINE ZYADNX(N1,N2)
  37.         INTEGER N1,N2
  38.  
  39. C---------------------------------------------------------
  40. C    TOOLPACK/1    Release: 2.5
  41. C---------------------------------------------------------
  42.         COMMON/XCTREE/ROOT,TREE,TRETOP
  43.         INTEGER ROOT,TREE(4,46339),TRETOP
  44.  
  45.         SAVE /XCTREE/
  46.  
  47.         INTEGER N2SUC
  48.  
  49.         INTEGER NEXT,PREV,UP,DOWN,NTYPE,NODE
  50.  
  51.         NEXT(NODE)=MOD(TREE(3,NODE),46340)
  52.         PREV(NODE)=(TREE(3,NODE)/46340)
  53.         UP(NODE)=(TREE(1,NODE)/46340)
  54.         DOWN(NODE)=TREE(2,NODE)
  55.         NTYPE(NODE)=MOD(TREE(1,NODE),46340)
  56.  
  57.         N2SUC=N2
  58.  100    N2SUC=PREV(N2SUC)
  59.         IF (PREV(N2SUC).NE.N2) GO TO 100
  60.         IF (UP(N1).NE.0) CALL ZYDELT(N1)
  61.         TREE(3,N1)=N2*46340+NEXT(N2)
  62.         TREE(1,N1)=UP(N2)*46340+NTYPE(N1)
  63.         TREE(3,N2SUC)=N1*46340+NEXT(N2SUC)
  64.         TREE(3,N2)=PREV(N2)*46340+N1
  65.  
  66.         END
  67. C ----------------------------------------------------------------------
  68. C
  69. C       Z Y A S T R   -   Add string to the string table
  70. C
  71.  
  72.         INTEGER FUNCTION ZYASTR(TEXT)
  73.         INTEGER TEXT(*)
  74.  
  75. C---------------------------------------------------------
  76. C    TOOLPACK/1    Release: 2.5
  77. C---------------------------------------------------------
  78.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  79.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  80.  
  81.         SAVE /XCSTRI/
  82.  
  83.  
  84.         INTEGER I,L
  85.         LOGICAL MATCH
  86.  
  87.         INTEGER EQUAL,LENGTH
  88.         EXTERNAL EQUAL,LENGTH,SCOPY,ERROR
  89.  
  90.         I=0
  91.         L=LENGTH(TEXT)
  92.         IF (NSTRNG.EQ.7103) CALL ERROR('Too many strings')
  93.         IF (TXTTOP+L+1.GE.46339)
  94.      +      CALL ERROR('String area overflowed')
  95.  
  96.  100    I=I+1
  97.         MATCH=EQUAL(STRTXT(STRTBL(I)),TEXT).EQ.-2
  98.         IF (I.LT.NSTRNG .AND. .NOT. MATCH) GOTO 100
  99.  
  100.         IF (MATCH) THEN
  101.             ZYASTR=STRTBL(I)
  102.         ELSE
  103.             ZYASTR=TXTTOP
  104.             NSTRNG=NSTRNG+1
  105.             STRTBL(NSTRNG)=TXTTOP
  106.             CALL SCOPY(TEXT,1,STRTXT,TXTTOP)
  107.             TXTTOP=TXTTOP+LENGTH(TEXT)+1
  108.         END IF
  109.  
  110.         END
  111. C ----------------------------------------------------------------------
  112. C
  113. C       Z Y A S Y M   -   Add (maybe) a new symbol
  114. C                         (return pointer to old symbol if any)
  115. C
  116.  
  117.         INTEGER FUNCTION ZYASYM(STRPTR,PUN,SYMTYP)
  118.         INTEGER SYMTYP,PUN,STRPTR
  119.  
  120.         INTEGER I
  121.         LOGICAL CBLK,NOTFND
  122.  
  123. C---------------------------------------------------------
  124. C    TOOLPACK/1    Release: 2.5
  125. C---------------------------------------------------------
  126.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  127.         INTEGER NSYMS,NPUS,PUIDX(250),
  128.      +          SYMBOL(8,5003)
  129.         LOGICAL MODFLG
  130.  
  131.         SAVE /XCSYMS/
  132.  
  133.         EXTERNAL ERROR
  134.  
  135.         CBLK=SYMTYP.EQ.2
  136.         ZYASYM=PUIDX(MIN(PUN,NPUS,250))
  137.         NOTFND=.TRUE.
  138.  
  139. C Find first symbol of program-unit
  140.  100    IF (SYMBOL(3,ZYASYM).LT.PUN) THEN
  141.             ZYASYM=ZYASYM+1
  142.             IF (ZYASYM.LE.NSYMS) GOTO 100
  143.             CALL ERROR('ZYASYM: Couldn''t find program unit')
  144.         END IF
  145.  
  146. C Try to find the symbol we want to insert
  147.  200    IF (ZYASYM.LE.NSYMS) THEN
  148.             IF (SYMBOL(2,ZYASYM).EQ.STRPTR .AND.
  149.      +          SYMBOL(3,ZYASYM).EQ.PUN .AND.
  150.      +          (CBLK.EQV.SYMBOL(1,ZYASYM).EQ.2)) THEN
  151.                 NOTFND=.FALSE.
  152.             ELSE
  153.                 ZYASYM=ZYASYM+1
  154.                 IF (SYMBOL(3,ZYASYM-1).EQ.PUN) GOTO 200
  155. C If symbol table has been modified, there might be extra symbols for
  156. C this program-unit added after the beginning of the next ...
  157.                 IF (MODFLG) GOTO 200
  158.             END IF
  159.         END IF
  160.         IF (NOTFND) THEN
  161.             IF (NSYMS.EQ.5003) CALL ERROR('Too many symbols')
  162.             NSYMS=NSYMS+1
  163.             MODFLG=.TRUE.
  164.             SYMBOL(1,NSYMS)=SYMTYP
  165.             SYMBOL(2,NSYMS)=STRPTR
  166.             SYMBOL(3,NSYMS)=PUN
  167.             DO 300 I=4,8
  168.  300            SYMBOL(I,NSYMS)=0
  169.             ZYASYM=NSYMS
  170.         ELSE
  171.             IF (SYMTYP.NE.3 .AND. SYMBOL(1,ZYASYM).NE.SYMTYP .AND.
  172.      +          (SYMTYP.NE.5 .OR. SYMBOL(1,ZYASYM).NE.4))
  173.      +          CALL ZYSERR('Inconsistent symbol types',ZYASYM,.TRUE.)
  174.         END IF
  175.  
  176.         END
  177. C ----------------------------------------------------------------------
  178. C
  179. C       Z Y C A T T   -   Check symbol Attribute (set it if zero)
  180. C
  181.  
  182.         SUBROUTINE ZYCATT(SYMPTR,ATTNUM,VALUE)
  183.         INTEGER SYMPTR,ATTNUM,VALUE
  184.  
  185. C---------------------------------------------------------
  186. C    TOOLPACK/1    Release: 2.5
  187. C---------------------------------------------------------
  188.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  189.         INTEGER NSYMS,NPUS,PUIDX(250),
  190.      +          SYMBOL(8,5003)
  191.         LOGICAL MODFLG
  192.  
  193.         SAVE /XCSYMS/
  194.  
  195.         IF (SYMBOL(ATTNUM,SYMPTR).NE.VALUE .AND.
  196.      +      SYMBOL(ATTNUM,SYMPTR).NE.0) THEN
  197.             CALL ZYSERR('Inconsistent symbol attributes',SYMPTR,.FALSE.)
  198.         ELSE
  199.             SYMBOL(ATTNUM,SYMPTR)=VALUE
  200.         ENDIF
  201.  
  202.         END
  203. C ----------------------------------------------------------------------
  204. C
  205. C       Z Y C H D N   -   Change down pointer
  206. C
  207.  
  208.         SUBROUTINE ZYCHDN(NODE,DOWN)
  209.         INTEGER NODE,DOWN
  210.  
  211. C---------------------------------------------------------
  212. C    TOOLPACK/1    Release: 2.5
  213. C---------------------------------------------------------
  214.         COMMON/XCTREE/ROOT,TREE,TRETOP
  215.         INTEGER ROOT,TREE(4,46339),TRETOP
  216.  
  217.         SAVE /XCTREE/
  218.  
  219.         TREE(2,NODE)=DOWN
  220.  
  221.         END
  222. C ----------------------------------------------------------------------
  223. C
  224. C       Z Y C H N T   -   Change node type
  225. C
  226.  
  227.         SUBROUTINE ZYCHNT(NODE,TYPE)
  228.         INTEGER NODE,TYPE
  229.  
  230.         INTRINSIC INT
  231.  
  232. C---------------------------------------------------------
  233. C    TOOLPACK/1    Release: 2.5
  234. C---------------------------------------------------------
  235.         COMMON/XCTREE/ROOT,TREE,TRETOP
  236.         INTEGER ROOT,TREE(4,46339),TRETOP
  237.  
  238.         SAVE /XCTREE/
  239.  
  240.         TREE(1,NODE)=INT(TREE(1,NODE)/46340)*46340+TYPE
  241.  
  242.         END
  243. C ----------------------------------------------------------------------
  244. C
  245. C       Z Y C R N D   -   Create a new node in the parse tree
  246. C
  247.  
  248. C
  249. C Note: when a new node is created, it has the status "deleted", ie the
  250. C       up pointer is zero, next is zero, prev is a backlink.
  251. C
  252. C
  253.  
  254.         INTEGER FUNCTION ZYCRND(TYPE,DOTTIR)
  255.         INTEGER TYPE,DOTTIR
  256.  
  257. C---------------------------------------------------------
  258. C    TOOLPACK/1    Release: 2.5
  259. C---------------------------------------------------------
  260.         COMMON/XCTREE/ROOT,TREE,TRETOP
  261.         INTEGER ROOT,TREE(4,46339),TRETOP
  262.  
  263.         SAVE /XCTREE/
  264.  
  265.         INTEGER PTR
  266.  
  267.         EXTERNAL ERROR
  268.  
  269.         IF (TRETOP.EQ.46339) CALL ERROR('Parse tree overflowed')
  270.         TRETOP=TRETOP+1
  271.         TREE(1,TRETOP)=TYPE
  272.         TREE(2,TRETOP)=DOTTIR
  273.         TREE(3,TRETOP)=TRETOP*46340
  274.         TREE(4,TRETOP)=0
  275.         IF (DOTTIR.GT.0) THEN
  276.             PTR=DOTTIR
  277.  100        TREE(1,PTR)=MOD(TREE(1,PTR),46340)+TRETOP*46340
  278.             PTR=MOD(TREE(3,PTR),46340)
  279.             IF (PTR.GT.0) GO TO 100
  280.         END IF
  281.         ZYCRND=TRETOP
  282.  
  283.         END
  284. C ----------------------------------------------------------------------
  285. C
  286. C       Z Y D E L T   -   Delete (sub)Tree
  287. C
  288.  
  289.         SUBROUTINE ZYDELT(SBROOT)
  290.         INTEGER SBROOT
  291.  
  292.         INTEGER SUC,P
  293.  
  294. C---------------------------------------------------------
  295. C    TOOLPACK/1    Release: 2.5
  296. C---------------------------------------------------------
  297. C
  298. C Common block and access functions for YP parse tree
  299. C
  300. C---------------------------------------------------------
  301. C    TOOLPACK/1    Release: 2.5
  302. C---------------------------------------------------------
  303.         COMMON/XCTREE/ROOT,TREE,TRETOP
  304.         INTEGER ROOT,TREE(4,46339),TRETOP
  305.  
  306.         SAVE /XCTREE/
  307. C Use "JABC12" to try to avoid conflicts with ordinary variables
  308.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  309.  
  310.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  311.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  312.         UP(JABC12)=(TREE(1,JABC12)/46340)
  313.         DOWN(JABC12)=TREE(2,JABC12)
  314.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  315.         NATTR(JABC12)=TREE(4,JABC12)
  316.  
  317.         P=PREV(SBROOT)
  318.         SUC=SBROOT
  319.  100    SUC=PREV(SUC)
  320.         IF (PREV(SUC).NE.SBROOT) GO TO 100
  321.         TREE(3,SUC)=NEXT(SUC)+46340*P
  322.         IF (DOWN(UP(SBROOT)).EQ.SBROOT) TREE(2,UP(SBROOT))=NEXT(SBROOT)
  323.         IF (NEXT(P).EQ.SBROOT) TREE(3,P)=PREV(P)*46340+NEXT(SBROOT)
  324.         TREE(1,SBROOT)=NTYPE(SBROOT)
  325.         TREE(3,SBROOT)=SBROOT*46340
  326.  
  327.         END
  328. C ----------------------------------------------------------------------
  329. C
  330. C       Z Y D O W N   -   Return down pointer of a node
  331. C
  332.  
  333.         INTEGER FUNCTION ZYDOWN(NODE)
  334.         INTEGER NODE
  335.  
  336. C---------------------------------------------------------
  337. C    TOOLPACK/1    Release: 2.5
  338. C---------------------------------------------------------
  339.         COMMON/XCTREE/ROOT,TREE,TRETOP
  340.         INTEGER ROOT,TREE(4,46339),TRETOP
  341.  
  342.         SAVE /XCTREE/
  343.  
  344.         ZYDOWN=TREE(2,NODE)
  345.  
  346.         END
  347. C ----------------------------------------------------------------------
  348. C
  349. C       Z Y F S Y M   -   Find Symbol (with a particular name)
  350. C
  351.  
  352.         INTEGER FUNCTION ZYFSYM(TEXT,PUN,RESULT)
  353.         INTEGER TEXT(*),PUN,RESULT(8)
  354.  
  355. C---------------------------------------------------------
  356. C    TOOLPACK/1    Release: 2.5
  357. C---------------------------------------------------------
  358.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  359.         INTEGER NSYMS,NPUS,PUIDX(250),
  360.      +          SYMBOL(8,5003)
  361.         LOGICAL MODFLG
  362.  
  363.         SAVE /XCSYMS/
  364. C---------------------------------------------------------
  365. C    TOOLPACK/1    Release: 2.5
  366. C---------------------------------------------------------
  367.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  368.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  369.  
  370.         SAVE /XCSTRI/
  371.  
  372.  
  373.         INTEGER I
  374.  
  375.         INTEGER EQUAL
  376.         EXTERNAL EQUAL,ERROR
  377.  
  378.         IF (PUN.GT.NPUS) CALL ERROR('ZYFSYM: NONEXISTENT P..U..')
  379.  
  380. C First find the first symbol in that program-unit
  381.         ZYFSYM=PUIDX(MIN(250,PUN))-1
  382.  100    ZYFSYM=ZYFSYM+1
  383.         IF (SYMBOL(3,ZYFSYM).NE.PUN .AND.
  384.      +      ZYFSYM.LT.NSYMS) GOTO 100
  385.         IF (SYMBOL(3,ZYFSYM).NE.PUN)
  386.      +      CALL ERROR('ZYFSYM: PROGRAM-UNIT NOT FOUND')
  387.  
  388. C Found start of symbols for that p.u. - look for the one we want
  389.  200    IF (SYMBOL(3,ZYFSYM).EQ.PUN .AND.
  390.      +      EQUAL(STRTXT(SYMBOL(2,ZYFSYM)),TEXT).EQ.-2) THEN
  391.             DO 300 I=1,8
  392.  300            RESULT(I)=SYMBOL(I,ZYFSYM)
  393.         ELSE IF (ZYFSYM.LT.NSYMS) THEN
  394.             ZYFSYM=ZYFSYM+1
  395.             IF (SYMBOL(3,ZYFSYM-1).EQ.PUN) GOTO 200
  396.             IF (MODFLG) GOTO 200
  397.             ZYFSYM=-1
  398.         ELSE
  399.             ZYFSYM=-1
  400.         END IF
  401.  
  402.         END
  403. C ----------------------------------------------------------------------
  404. C
  405. C       Z Y G D S D   -   Get Declaration Standardiser Data
  406. C
  407.  
  408.         SUBROUTINE ZYGDSD(SYMIDX,STYPE,SDTYPE,SCHLEN,SBITS,N)
  409.         INTEGER N
  410.         INTEGER SYMIDX(N),STYPE(N),SDTYPE(N),SCHLEN(N),SBITS(N)
  411.  
  412. C---------------------------------------------------------
  413. C    TOOLPACK/1    Release: 2.5
  414. C---------------------------------------------------------
  415.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  416.         INTEGER NSYMS,NPUS,PUIDX(250),
  417.      +          SYMBOL(8,5003)
  418.         LOGICAL MODFLG
  419.  
  420.         SAVE /XCSYMS/
  421. C---------------------------------------------------------
  422. C    TOOLPACK/1    Release: 2.5
  423. C---------------------------------------------------------
  424.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  425.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  426.  
  427.         SAVE /XCSTRI/
  428.  
  429.  
  430.         INTEGER I,II
  431.  
  432.         INTEGER ZIAND
  433.         EXTERNAL ZIAND,ZCHOUT,PUTLIN,ZMESS
  434.  
  435.         DO 100 II=1,N
  436.             I=SYMIDX(II)
  437.             IF (SYMBOL(1,I).EQ.1) THEN
  438.                 SDTYPE(II)=0
  439.                 SCHLEN(II)=0
  440.                 SBITS(II)=0
  441.                 STYPE(II)=20
  442.             ELSE IF (SYMBOL(1,I).EQ.2) THEN
  443.                 SDTYPE(II)=0
  444.                 SCHLEN(II)=0
  445.                 SBITS(II)=0
  446.                 STYPE(II)=13
  447.             ELSE
  448.                 SBITS(II)=SYMBOL(6,I)
  449.                 SDTYPE(II)=SYMBOL(4,I)
  450.                 SCHLEN(II)=SYMBOL(5,I)
  451.                 IF (SYMBOL(1,I).EQ.6) THEN
  452.                     STYPE(II)=1
  453.                 ELSE IF (SYMBOL(1,I).EQ.7) THEN
  454.                     STYPE(II)=10
  455.                     IF (SYMBOL(4,I).EQ.-1)
  456.      +                  STYPE(II)=11
  457.                     IF (ZIAND(SYMBOL(6,I),
  458.      +                        4096+2).NE.0)
  459.      +                  STYPE(II)=12
  460.                     IF (ZIAND(SYMBOL(6,I),4).NE.0)
  461.      +                  STYPE(II)=STYPE(II)-6
  462.                 ELSE IF (SYMBOL(1,I).EQ.8) THEN
  463.                     STYPE(II)=14
  464.                 ELSE IF (SYMBOL(1,I).EQ.4) THEN
  465.                     STYPE(II)=0
  466.                 ELSE IF (SYMBOL(1,I).EQ.9) THEN
  467.                     STYPE(II)=15
  468.                 ELSE
  469.                     IF (SYMBOL(1,I).NE.5 .AND.
  470.      +                  SYMBOL(1,I).NE.3) THEN
  471.                         CALL ZCHOUT('ZYGDSD: Strange item found - "',
  472.      +                              2)
  473.                         CALL PUTLIN(STRTXT(SYMBOL(2,I)),2)
  474.                         CALL ZMESS('"',2)
  475.                     END IF
  476.                     STYPE(II)=8
  477.                     IF (SYMBOL(7,I).NE.0) STYPE(II)=STYPE(II)+1
  478.                     IF (ZIAND(SYMBOL(6,I),4).NE.0)
  479.      +                  STYPE(II)=STYPE(II)-6
  480.                     IF (ZIAND(SYMBOL(6,I),1024).NE.0)
  481.      +                  STYPE(II)=STYPE(II)-2
  482.                 END IF
  483.             END IF
  484.  100    CONTINUE
  485.  
  486.         END
  487. C ----------------------------------------------------------------------
  488. C
  489. C       Z Y G N S W   -   Get Next Symbol Within program-unit
  490. C
  491.  
  492.         INTEGER FUNCTION ZYGNSW(SYMPTR,PUN,RESULT)
  493.         INTEGER SYMPTR,PUN,RESULT(8)
  494.  
  495. C---------------------------------------------------------
  496. C    TOOLPACK/1    Release: 2.5
  497. C---------------------------------------------------------
  498.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  499.         INTEGER NSYMS,NPUS,PUIDX(250),
  500.      +          SYMBOL(8,5003)
  501.         LOGICAL MODFLG
  502.  
  503.         SAVE /XCSYMS/
  504.  
  505.         INTEGER I
  506.  
  507.         ZYGNSW=-100
  508.         IF (SYMPTR.EQ.0) SYMPTR=PUIDX(MIN(PUN,NPUS,250))-1
  509.  100    SYMPTR=SYMPTR+1
  510.         IF (SYMPTR.GT.NSYMS) RETURN
  511.         IF (SYMBOL(3,SYMPTR).LT.PUN) GOTO 100
  512.         IF (SYMBOL(3,SYMPTR).NE.PUN) THEN
  513.             IF (MODFLG) GOTO 100
  514.             RETURN
  515.         END IF
  516.         DO 200 I=1,8
  517.  200        RESULT(I)=SYMBOL(I,SYMPTR)
  518.         ZYGNSW=-2
  519.  
  520.         END
  521. C ----------------------------------------------------------------------
  522. C
  523. C       Z Y G N S Y   -   Get Next Symbol
  524. C
  525.  
  526.         INTEGER FUNCTION ZYGNSY(SYMPTR,RESULT)
  527.         INTEGER SYMPTR,RESULT(8)
  528.  
  529. C---------------------------------------------------------
  530. C    TOOLPACK/1    Release: 2.5
  531. C---------------------------------------------------------
  532.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  533.         INTEGER NSYMS,NPUS,PUIDX(250),
  534.      +          SYMBOL(8,5003)
  535.         LOGICAL MODFLG
  536.  
  537.         SAVE /XCSYMS/
  538.  
  539.         INTEGER I
  540.  
  541.         SYMPTR=SYMPTR+1
  542.         IF (SYMPTR.GT.NSYMS) THEN
  543.             ZYGNSY=-100
  544.         ELSE
  545.             DO 100 I=1,8
  546.  100            RESULT(I)=SYMBOL(I,SYMPTR)
  547.             ZYGNSY=-2
  548.         END IF
  549.  
  550.         END
  551. C ----------------------------------------------------------------------
  552. C
  553. C       Z Y G S S I   -   Get Sorted Symbol Index - This is DECS' vers.,
  554. C                         and cheats by not returning "in_include" syms.
  555. C
  556. C       NOTE: This all relies on the field "common_size" (which is in
  557. C             the same position as the "name_status" field for vars)
  558. C             being zero for common blocks after parsing - it should
  559. C             still work after static semantic analysis, even though this
  560. C             sets the value of this field (to the size of the common
  561. C             common block in char storage units) unless the common is
  562. C             very big (2097152 char storage units or larger - i.e. more
  563. C             than 2 MB in a single common block).
  564. C
  565.  
  566.         SUBROUTINE ZYGSSI(SYMIDX,N,PUN)
  567.         INTEGER SYMIDX(*),N,PUN
  568.  
  569. C---------------------------------------------------------
  570. C    TOOLPACK/1    Release: 2.5
  571. C---------------------------------------------------------
  572.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  573.         INTEGER NSYMS,NPUS,PUIDX(250),
  574.      +          SYMBOL(8,5003)
  575.         LOGICAL MODFLG
  576.  
  577.         SAVE /XCSYMS/
  578. C---------------------------------------------------------
  579. C    TOOLPACK/1    Release: 2.5
  580. C---------------------------------------------------------
  581.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  582.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  583.  
  584.         SAVE /XCSTRI/
  585.  
  586.  
  587.         INTEGER I,L,R,O,SYM
  588.  
  589.         INTEGER ZORDER,ZIAND
  590.         EXTERNAL ZORDER,ZIAND
  591.  
  592.         N=0
  593.         SYM=PUIDX(MIN(PUN,NPUS,250))-1
  594.  
  595.  100    SYM=SYM+1
  596.         IF (SYMBOL(3,SYM).LT.PUN .AND. SYM.LT.NSYMS) GOTO 100
  597.  
  598.  200    IF (SYMBOL(3,SYM).EQ.PUN .AND.
  599.      +      ZIAND(SYMBOL(6,SYM),2097152).NE.0) THEN
  600.             SYM=SYM+1
  601.             IF (SYM.LE.NSYMS) GOTO 200
  602.         ELSE IF (SYMBOL(3,SYM).EQ.PUN) THEN
  603.             N=N+1
  604.             IF (N.EQ.1) THEN
  605.                 SYMIDX(1)=SYM
  606.             ELSE
  607. C Use binary insertion
  608.                 L=1
  609.                 R=N-1
  610. C While (l<=r) do
  611.  300            I=(L+R)/2
  612.                 O=ZORDER(STRTXT(SYMBOL(2,SYM)),
  613.      +                   STRTXT(SYMBOL(2,SYMIDX(I))))
  614.                 IF (O.EQ.60) THEN
  615.                     R=I-1
  616.                 ELSE
  617.                     L=I+1
  618.                 END IF
  619.                 IF (L.LE.R) GOTO 300
  620. C od
  621.                 DO 400 I=N-1,L,-1
  622.  400                SYMIDX(I+1)=SYMIDX(I)
  623.                 SYMIDX(L)=SYM
  624.             END IF
  625.             SYM=SYM+1
  626.             IF (SYM.LE.NSYMS) GOTO 200
  627.         ELSE IF (MODFLG) THEN
  628.             SYM=SYM+1
  629.             IF (SYM.LE.NSYMS) GOTO 200
  630.         END IF
  631.  
  632.         END
  633. C ----------------------------------------------------------------------
  634. C
  635. C       Z Y G T S T   -   Get string from string pointer
  636. C
  637.  
  638.         SUBROUTINE ZYGTST(STRPTR,TEXT)
  639.         INTEGER STRPTR,TEXT(*)
  640.  
  641. C---------------------------------------------------------
  642. C    TOOLPACK/1    Release: 2.5
  643. C---------------------------------------------------------
  644.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  645.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  646.  
  647.         SAVE /XCSTRI/
  648.  
  649.  
  650.         EXTERNAL SCOPY
  651.  
  652.         CALL SCOPY(STRTXT,STRPTR,TEXT,1)
  653.  
  654.         END
  655. C ----------------------------------------------------------------------
  656. C
  657. C       Z Y G T S Y   -   Get Symbol
  658. C
  659.  
  660.         SUBROUTINE ZYGTSY(SYMPTR,RESULT)
  661.         INTEGER SYMPTR,RESULT(8)
  662.  
  663. C---------------------------------------------------------
  664. C    TOOLPACK/1    Release: 2.5
  665. C---------------------------------------------------------
  666.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  667.         INTEGER NSYMS,NPUS,PUIDX(250),
  668.      +          SYMBOL(8,5003)
  669.         LOGICAL MODFLG
  670.  
  671.         SAVE /XCSYMS/
  672.  
  673.         INTEGER I
  674.  
  675.         DO 100 I=1,8
  676.  100        RESULT(I)=SYMBOL(I,SYMPTR)
  677.  
  678.         END
  679. C ----------------------------------------------------------------------
  680. C
  681. C       Z Y I N C I   -   Input Comment Index
  682. C
  683.  
  684.         INTEGER FUNCTION ZYINCI(FD)
  685.         INTEGER FD
  686.         INTEGER IODCMT,STMTNO,BUFF(*)
  687.  
  688.         INTEGER CIOVFP,CISIZE,BIGNUM
  689.         PARAMETER (CIOVFP=150,CISIZE=300,BIGNUM=1000000)
  690.  
  691. C CISIZE = maximum in-memory index size
  692. C CIOVFP = overflow point (only when really big)
  693. C BIGNUM = a number which is bigger than any conceivable statement no.
  694.  
  695.         INTEGER IODCI,MEMCI(3,CISIZE),NINMEM,BUFFER(134),STATUS,I,
  696.      +          PNTR,CURCMT,LOWEST,LAST
  697.         LOGICAL FETCH
  698.  
  699.         SAVE
  700.  
  701.         INTEGER ZYGTCM,ZYGNCM,ZYCMEX
  702.  
  703.         INTEGER CTOI,ZGTCMD,XCMTRD
  704.         EXTERNAL CTOI,ZGTCMD,SEEK
  705.  
  706. C Index structure:  (1,*)=statement number
  707. C                   (2,*)=first comment number
  708. C                   (3,*)=last comment number
  709. C
  710. C Up to NINMEM: current "in-memory" index
  711. C From NINMEM+1 to OVFMAX: overflow area
  712. C BIG: whether there is an overflow area or not
  713.  
  714.         IODCI=FD
  715.         NINMEM=0
  716.         MEMCI(1,1)=0
  717.         LAST=BIGNUM
  718.  
  719.  100    STATUS=ZGTCMD(BUFFER,IODCI)
  720.         IF (STATUS.EQ.-1) CALL ERROR('I/O Error reading comment index')
  721.         IF (STATUS.NE.-100) THEN
  722.             PNTR=1
  723.             NINMEM=NINMEM+1
  724.             MEMCI(1,NINMEM)=CTOI(BUFFER,PNTR)
  725.             MEMCI(2,NINMEM)=CTOI(BUFFER,PNTR)
  726.             MEMCI(3,NINMEM)=CTOI(BUFFER,PNTR)
  727.             IF (NINMEM.LT.CISIZE) GO TO 100
  728. C We have overflowed - remember it!
  729.             LAST=MEMCI(1,CISIZE)
  730.         END IF
  731.         LOWEST=1
  732.         ZYINCI=-2
  733.         RETURN
  734.  
  735.         ENTRY ZYGTCM(IODCMT,STMTNO,BUFF)
  736.  
  737.         FETCH=.TRUE.
  738.         GOTO 200
  739.  
  740.         ENTRY ZYCMEX(STMTNO)
  741.  
  742.         FETCH=.FALSE.
  743.  
  744. C Find the index entry ...
  745. C ... first see if we need to load a different index
  746.  
  747.  200    IF (STMTNO.LT.LOWEST .OR. STMTNO.GT.LAST) THEN
  748.             IF (STMTNO.LT.LOWEST) THEN
  749.                 IF (STMTNO.LE.0)
  750.      +              CALL ERROR('ZYGTCM: NON-POSITIVE STMT NUMBER')
  751. C Clear entire index and refill from the bottom
  752.                 CALL SEEK(0,IODCI)
  753.                 LOWEST=0
  754.                 NINMEM=0
  755.             ELSE IF (STMTNO.GT.LAST) THEN
  756. C Clear lower portion and replace with the next higher portion
  757. C ... do it by moving higher portion down ...
  758.                 LOWEST=MEMCI(1,CIOVFP)+1
  759.                 DO 300 I=1,CIOVFP
  760.                     MEMCI(1,I)=MEMCI(1,I+CIOVFP)
  761.                     MEMCI(2,I)=MEMCI(2,I+CIOVFP)
  762.                     MEMCI(3,I)=MEMCI(3,I+CIOVFP)
  763.  300            CONTINUE
  764.                 NINMEM=CIOVFP
  765.             END IF
  766.  400        STATUS=ZGTCMD(BUFFER,IODCI)
  767.             IF (STATUS.NE.-100) THEN
  768.                 NINMEM=NINMEM+1
  769.                 PNTR=1
  770.                 MEMCI(1,NINMEM)=CTOI(BUFFER,PNTR)
  771.                 MEMCI(2,NINMEM)=CTOI(BUFFER,PNTR)
  772.                 MEMCI(3,NINMEM)=CTOI(BUFFER,PNTR)
  773.                 IF (NINMEM.LT.CISIZE) GOTO 400
  774.             END IF
  775.             LAST=MEMCI(1,NINMEM)
  776.             IF (STATUS.EQ.-100) LAST=BIGNUM
  777.             GOTO 200
  778.         END IF
  779.  
  780. C Loaded correct part of index - see if it is there
  781.  
  782.         I=0
  783.  500    I=I+1
  784.         IF (MEMCI(1,I).LT.STMTNO .AND. I.LT.NINMEM) GOTO 500
  785.  
  786. C Found it or it isn't there - return comment or status
  787. C as appropriate
  788.  
  789.         IF (FETCH) THEN
  790.             IF (MEMCI(1,I).EQ.STMTNO) THEN
  791.                 CURCMT=MEMCI(2,I)
  792.                 ZYGTCM=XCMTRD(IODCMT,CURCMT,BUFF)
  793.             ELSE
  794.                 ZYGTCM=-100
  795.             END IF
  796.         ELSE
  797.             IF (MEMCI(1,I).EQ.STMTNO) THEN
  798.                 ZYCMEX=-2
  799.             ELSE
  800.                 ZYCMEX=-3
  801.             END IF
  802.         END IF
  803.         RETURN
  804.  
  805.         ENTRY ZYGNCM(IODCMT,BUFF)
  806.  
  807.         IF (CURCMT.EQ.MEMCI(3,I)) THEN
  808.             ZYGNCM=-100
  809.         ELSE
  810.             CURCMT=CURCMT+1
  811.             ZYGNCM=XCMTRD(IODCMT,CURCMT,BUFF)
  812.         END IF
  813.  
  814.         END
  815. C ----------------------------------------------------------------------
  816. C
  817. C       X C M T R D   -   (internal) read comment file
  818. C
  819.  
  820.         INTEGER FUNCTION XCMTRD(IODCMT,CMTNUM,BUFFER)
  821.         INTEGER IODCMT,CMTNUM,BUFFER(*)
  822.  
  823.         INTEGER CHSIZE
  824.         PARAMETER (CHSIZE=10)
  825.  
  826.         INTEGER LSTCMT,CACHE(0:134,CHSIZE),I,CHNUM
  827.  
  828.         SAVE LSTCMT,CACHE,CHNUM
  829.  
  830.         INTEGER XXCMRD,XCMREW
  831.         EXTERNAL ERROR,SCOPY
  832.  
  833.         DATA LSTCMT/-1/,CHNUM/1/
  834.  
  835.         IF (LSTCMT.EQ.-1) THEN
  836.             LSTCMT=0
  837.             DO 100 I=1,CHSIZE
  838.                 CACHE(0,I)=0
  839.  100        CONTINUE
  840.         ELSE IF (LSTCMT.NE.CMTNUM-1) THEN
  841.             DO 200 I=1,CHSIZE
  842.                 IF (CMTNUM.EQ.CACHE(0,I)) THEN
  843.                     CALL SCOPY(CACHE(1,I),1,BUFFER,1)
  844.                     XCMTRD=-2
  845.                     RETURN
  846.                 END IF
  847.  200        CONTINUE
  848.         END IF
  849.  
  850.         IF (LSTCMT.GE.CMTNUM) THEN
  851.             XCMTRD=XCMREW(IODCMT)
  852.             IF (XCMTRD.NE.-2) CALL ERROR('Unexpected Error from XCMREW')
  853.             LSTCMT=0
  854.         END IF
  855.  
  856.  300    CONTINUE
  857.         LSTCMT=LSTCMT+1
  858.         IF (LSTCMT.LT.CMTNUM) THEN
  859.             CHNUM=MOD(CHNUM,CHSIZE)+1
  860.             CACHE(0,CHNUM)=LSTCMT
  861.             XCMTRD=XXCMRD(CACHE(1,CHNUM),IODCMT)
  862.             IF (XCMTRD.EQ.-2) GOTO 300
  863.         ELSE
  864.             XCMTRD=XXCMRD(BUFFER,IODCMT)
  865.         END IF
  866.         IF (XCMTRD.EQ.-100) THEN
  867.             CALL ERROR('Internal Error: end-of-file reading comments')
  868.         ELSE IF (XCMTRD.EQ.-1) THEN
  869.             CALL ERROR('I/O er'//'ror reading comments')
  870.         END IF
  871.  
  872.         END
  873. C ----------------------------------------------------------------------
  874. C
  875. C       X X C M R D   -   Even more internal "read comment file"
  876. C
  877. C       Just reads the next comment from the comment file
  878. C
  879. C       Also provides an ENTRY point for rewinding it
  880. C
  881.  
  882.         INTEGER FUNCTION XXCMRD(BUFFER,IODCMT)
  883.  
  884.         INTEGER XCMREW
  885.  
  886.         INTEGER BUFFER(*),IODCMT
  887.  
  888.         INTEGER LIMIT,SIZE
  889.         PARAMETER (LIMIT=132, SIZE=LIMIT+2)
  890.  
  891.         INTEGER POINTR,IBUFF(SIZE),I,FIRST,SECOND,LENT,C
  892.  
  893.         SAVE POINTR,IBUFF
  894.  
  895.         EXTERNAL SEEK,XTKSUB
  896.  
  897.         DATA POINTR/SIZE/
  898.  
  899.  100    CONTINUE
  900.         CALL XTKSUB(FIRST,POINTR,IBUFF,LIMIT,IODCMT,XXCMRD)
  901.         IF (XXCMRD.NE.-2) RETURN
  902.         CALL XTKSUB(SECOND,POINTR,IBUFF,LIMIT,IODCMT,XXCMRD)
  903.         IF (XXCMRD.NE.-2) RETURN
  904.  
  905.         LENT = (FIRST-48)*10+SECOND-48
  906.         DO 200 I=1,LENT
  907.             CALL XTKSUB(C,POINTR,IBUFF,LIMIT,IODCMT,XXCMRD)
  908.             IF (XXCMRD.NE.-2) RETURN
  909.             BUFFER(I) = C
  910.  200    CONTINUE
  911.         BUFFER(I) = 129
  912.         IF (BUFFER(1).EQ.36) GO TO 100
  913.  
  914.         RETURN
  915.  
  916.         ENTRY XCMREW(IODCMT)
  917.  
  918.         CALL SEEK(0,IODCMT)
  919.         POINTR=SIZE
  920.         XCMREW=-2
  921.  
  922.         END
  923. C ----------------------------------------------------------------------
  924. C
  925. C       Z Y I N P T   -   Input parse tree from file
  926. C
  927.  
  928.         SUBROUTINE ZYINPT(IOD)
  929.         INTEGER IOD
  930.  
  931. C---------------------------------------------------------
  932. C    TOOLPACK/1    Release: 2.5
  933. C---------------------------------------------------------
  934.         COMMON/XCTREE/ROOT,TREE,TRETOP
  935.         INTEGER ROOT,TREE(4,46339),TRETOP
  936.  
  937.         SAVE /XCTREE/
  938.  
  939.         INTEGER TYPE,DOWN,NEXT,PREV,UP,STATUS,BUFF(134),PNTR,I,EXTN
  940.  
  941.         INTEGER GETLIN,ZSCTOI
  942.         EXTERNAL GETLIN,ZSCTOI,ERROR
  943.  
  944.         STATUS=GETLIN(BUFF,IOD)
  945.         PNTR=1
  946.         ROOT=ZSCTOI(BUFF,PNTR)
  947.         TRETOP=ZSCTOI(BUFF,PNTR)
  948.  
  949.         DO 100 I=1,TRETOP
  950.             IF (MOD(I,3).EQ.1) THEN
  951.                 STATUS=GETLIN(BUFF,IOD)
  952.                 IF (STATUS.EQ.-100)
  953.      +              CALL ERROR('Invalid parse tree file')
  954.                 PNTR=1
  955.             END IF
  956.             TYPE=ZSCTOI(BUFF,PNTR)
  957.             DOWN=ZSCTOI(BUFF,PNTR)
  958.             NEXT=ZSCTOI(BUFF,PNTR)
  959.             PREV=ZSCTOI(BUFF,PNTR)
  960.             UP=ZSCTOI(BUFF,PNTR)
  961.             IF (BUFF(PNTR).EQ.129) CALL ERROR('Corrupt parse tree file')
  962.             EXTN=ZSCTOI(BUFF,PNTR)
  963.             TREE(1,I)=TYPE+46340*UP
  964.             TREE(2,I)=DOWN
  965.             TREE(3,I)=NEXT+46340*PREV
  966.             TREE(4,I)=EXTN
  967.  100    CONTINUE
  968.  
  969.         END
  970. C ----------------------------------------------------------------------
  971. C
  972. C       Z Y I N S Y   -   Input symbol table (including strings)
  973. C
  974.  
  975.         SUBROUTINE ZYINSY(IOD)
  976.         INTEGER IOD
  977.  
  978. C---------------------------------------------------------
  979. C    TOOLPACK/1    Release: 2.5
  980. C---------------------------------------------------------
  981.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  982.         INTEGER NSYMS,NPUS,PUIDX(250),
  983.      +          SYMBOL(8,5003)
  984.         LOGICAL MODFLG
  985.  
  986.         SAVE /XCSYMS/
  987. C---------------------------------------------------------
  988. C    TOOLPACK/1    Release: 2.5
  989. C---------------------------------------------------------
  990.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  991.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  992.  
  993.         SAVE /XCSTRI/
  994.  
  995.  
  996.         INTEGER STATUS,BUFF(134),INCHAR,PNTR,I,J,STRNUM,
  997.      +          BUFPTR
  998.         LOGICAL FSTEMS
  999.  
  1000.         INTEGER GETLIN,ZSCTOI
  1001.         EXTERNAL GETLIN,ZSCTOI,ZMESS,ZCHOUT,PUTLIN,ERROR,REMARK
  1002.  
  1003. C
  1004. C Input the string table (There may be error/warning messages)
  1005. C
  1006.         FSTEMS=.TRUE.
  1007.  100    STATUS=GETLIN(BUFF,IOD)
  1008.         IF (BUFF(1).EQ.69 .OR. BUFF(1).EQ.87) THEN
  1009.             IF (FSTEMS) THEN
  1010.                 CALL ZMESS('Source program has errors/warnings:',2)
  1011.                 FSTEMS=.FALSE.
  1012.             END IF
  1013.             CALL ZCHOUT('   ',2)
  1014.             CALL PUTLIN(BUFF,2)
  1015.             GOTO 100
  1016.         END IF
  1017.         PNTR=1
  1018.         NSTRNG=ZSCTOI(BUFF,PNTR)
  1019. C All programs have at least one string - the p.u. name!!!
  1020.         IF (NSTRNG.EQ.0) CALL ERROR('ZYINSY: Not a symbol table file')
  1021.         TXTTOP=ZSCTOI(BUFF,PNTR)
  1022.         STRNUM=0
  1023.         STRTBL(1)=1
  1024.         BUFPTR=0
  1025.  
  1026.         DO 400 I=1,TXTTOP-1
  1027.             IF (BUFPTR.EQ.0) THEN
  1028.                 STATUS=GETLIN(BUFF,IOD)
  1029.                 DO 200 J=STATUS,132
  1030.  200                BUFF(J)=32
  1031.                 BUFF(132+1)=129
  1032.                 BUFPTR=1
  1033.             END IF
  1034.             INCHAR=BUFF(BUFPTR)
  1035.             BUFPTR=MOD(BUFPTR+1,132+1)
  1036.             IF (INCHAR.EQ.39) THEN
  1037.                 INCHAR=0
  1038.             ELSE IF (INCHAR.EQ.47) THEN
  1039.                 IF (BUFPTR.EQ.0) THEN
  1040.                     STATUS=GETLIN(BUFF,IOD)
  1041.                     DO 300 J=STATUS,132
  1042.  300                    BUFF(J)=32
  1043.                      BUFF(132+1)=129
  1044.                     BUFPTR=1
  1045.                 END IF
  1046.                 INCHAR=BUFF(BUFPTR)
  1047.                 BUFPTR=MOD(BUFPTR+1,132+1)
  1048.             END IF
  1049.             IF (INCHAR.EQ.0) THEN
  1050.                 STRNUM=STRNUM+1
  1051.                 STRTBL(STRNUM+1)=I+1
  1052.                 STRTXT(I)=129
  1053.             ELSE
  1054.                 STRTXT(I)=INCHAR
  1055.             END IF
  1056.  400    CONTINUE
  1057.         IF (STRNUM.NE.NSTRNG) CALL ERROR('Inconsistent string table')
  1058.         IF (STRTXT(TXTTOP-1).NE.129) CALL ERROR('Corrupted symbol file')
  1059.  
  1060. C
  1061. C Input the symbol table
  1062. C
  1063.         STATUS=GETLIN(BUFF,IOD)
  1064.         IF (STATUS.LT.-2) CALL ERROR('Incomplete symbol table file')
  1065.         PNTR=1
  1066.         NSYMS=ZSCTOI(BUFF,PNTR)
  1067.         NPUS=ZSCTOI(BUFF,PNTR)
  1068.         IF (ZSCTOI(BUFF,PNTR).NE.250)
  1069.      +      CALL ERROR('Incompatible format of symbol table file')
  1070.         MODFLG=ZSCTOI(BUFF,PNTR).EQ.1
  1071.         IF (BUFF(PNTR-1).NE.48 .AND. .NOT.MODFLG) THEN
  1072.             CALL REMARK('Old symbol table format - continuing')
  1073.             MODFLG=.TRUE.
  1074.         END IF
  1075.         DO 600 I=1,NSYMS
  1076.             IF (MOD(I,2).EQ.1) THEN
  1077.                 STATUS=GETLIN(BUFF,IOD)
  1078.                 IF (STATUS.EQ.-100)
  1079.      +              CALL ERROR('Unexpected end of symbol file')
  1080.                 PNTR=1
  1081.             END IF
  1082.             DO 500 J=1,8
  1083.                 SYMBOL(J,I)=ZSCTOI(BUFF,PNTR)
  1084.  500        CONTINUE
  1085.  600    CONTINUE
  1086.         IF (SYMBOL(1,NSYMS).EQ.0) CALL ERROR('Invalid symbol table')
  1087. C
  1088. C Input the Program-Unit Index
  1089. C
  1090.         DO 700 I=1,MIN(NPUS,250)
  1091.             IF (MOD(I,22).EQ.1) THEN
  1092.                 STATUS=GETLIN(BUFF,IOD)
  1093.                 IF (STATUS.EQ.-100)
  1094.      +              CALL ERROR('Unexpected end of symbol file')
  1095.                 PNTR=1
  1096.             END IF
  1097.             PUIDX(I)=ZSCTOI(BUFF,PNTR)
  1098.  700    CONTINUE
  1099.  
  1100.         END
  1101. C ----------------------------------------------------------------------
  1102. C
  1103. C       Z Y N E X T   -   Return next pointer of a node
  1104. C
  1105.  
  1106.         INTEGER FUNCTION ZYNEXT(NODE)
  1107.         INTEGER NODE
  1108.  
  1109.         INTRINSIC MOD
  1110.  
  1111. C---------------------------------------------------------
  1112. C    TOOLPACK/1    Release: 2.5
  1113. C---------------------------------------------------------
  1114.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1115.         INTEGER ROOT,TREE(4,46339),TRETOP
  1116.  
  1117.         SAVE /XCTREE/
  1118.  
  1119.         ZYNEXT=MOD(TREE(3,NODE),46340)
  1120.  
  1121.         END
  1122. C ----------------------------------------------------------------------
  1123. C
  1124. C       Z Y N T Y P   -   Return type of a node
  1125. C
  1126.  
  1127.         INTEGER FUNCTION ZYNTYP(NODE)
  1128.         INTEGER NODE
  1129.  
  1130.         INTRINSIC MOD
  1131.  
  1132. C---------------------------------------------------------
  1133. C    TOOLPACK/1    Release: 2.5
  1134. C---------------------------------------------------------
  1135.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1136.         INTEGER ROOT,TREE(4,46339),TRETOP
  1137.  
  1138.         SAVE /XCTREE/
  1139.  
  1140.         ZYNTYP=MOD(TREE(1,NODE),46340)
  1141.  
  1142.         END
  1143. C ----------------------------------------------------------------------
  1144. C
  1145. C       Z Y P R E V   -   Return previous pointer of a node
  1146. C
  1147.  
  1148.         INTEGER FUNCTION ZYPREV(NODE)
  1149.         INTEGER NODE
  1150.  
  1151. C---------------------------------------------------------
  1152. C    TOOLPACK/1    Release: 2.5
  1153. C---------------------------------------------------------
  1154.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1155.         INTEGER ROOT,TREE(4,46339),TRETOP
  1156.  
  1157.         SAVE /XCTREE/
  1158.  
  1159.         ZYPREV=TREE(3,NODE)/46340
  1160.  
  1161.         END
  1162. C ----------------------------------------------------------------------
  1163. C
  1164. C       Z Y R E P L   -   Replace node
  1165. C
  1166.  
  1167.         SUBROUTINE ZYREPL(N1,N2)
  1168.         INTEGER N1,N2
  1169.  
  1170.         CALL ZYADNX(N2,N1)
  1171.         CALL ZYDELT(N1)
  1172.  
  1173.         END
  1174. C ----------------------------------------------------------------------
  1175. C
  1176. C       Z Y R O O T   -   Return number of root node of parse tree
  1177. C
  1178.  
  1179.         INTEGER FUNCTION ZYROOT()
  1180.  
  1181. C---------------------------------------------------------
  1182. C    TOOLPACK/1    Release: 2.5
  1183. C---------------------------------------------------------
  1184.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1185.         INTEGER ROOT,TREE(4,46339),TRETOP
  1186.  
  1187.         SAVE /XCTREE/
  1188.  
  1189.         ZYROOT=ROOT
  1190.  
  1191.         END
  1192. C ----------------------------------------------------------------------
  1193. C
  1194. C       Z Y S A B T   -   Set atttibute bits
  1195. C
  1196.  
  1197.         SUBROUTINE ZYSABT(SYMPTR,ATTNUM,BITS)
  1198.         INTEGER SYMPTR,ATTNUM,BITS
  1199.  
  1200. C---------------------------------------------------------
  1201. C    TOOLPACK/1    Release: 2.5
  1202. C---------------------------------------------------------
  1203.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1204.         INTEGER NSYMS,NPUS,PUIDX(250),
  1205.      +          SYMBOL(8,5003)
  1206.         LOGICAL MODFLG
  1207.  
  1208.         SAVE /XCSYMS/
  1209.  
  1210.         INTEGER ZIOR
  1211.         EXTERNAL ZIOR
  1212.  
  1213.         SYMBOL(ATTNUM,SYMPTR)=ZIOR(SYMBOL(ATTNUM,SYMPTR),BITS)
  1214.  
  1215.         END
  1216. C ----------------------------------------------------------------------
  1217. C
  1218. C       Z Y S A T T   -   Set symbol Attribute (overrides current value)
  1219. C
  1220.  
  1221.         SUBROUTINE ZYSATT(SYMPTR,ATTNUM,VALUE)
  1222.         INTEGER SYMPTR,ATTNUM,VALUE
  1223.  
  1224. C---------------------------------------------------------
  1225. C    TOOLPACK/1    Release: 2.5
  1226. C---------------------------------------------------------
  1227.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1228.         INTEGER NSYMS,NPUS,PUIDX(250),
  1229.      +          SYMBOL(8,5003)
  1230.         LOGICAL MODFLG
  1231.  
  1232.         SAVE /XCSYMS/
  1233.  
  1234.         SYMBOL(ATTNUM,SYMPTR)=VALUE
  1235.  
  1236.         END
  1237. C ----------------------------------------------------------------------
  1238. C
  1239. C       Z Y T O U T   -   Output parse tree
  1240. C
  1241.  
  1242.         SUBROUTINE ZYTOUT(IOD)
  1243.         INTEGER IOD
  1244.  
  1245.         INTEGER I
  1246.  
  1247.         EXTERNAL ZPTINT,PUTCH,CLOSE
  1248.  
  1249. C---------------------------------------------------------
  1250. C    TOOLPACK/1    Release: 2.5
  1251. C---------------------------------------------------------
  1252. C
  1253. C Common block and access functions for YP parse tree
  1254. C
  1255. C---------------------------------------------------------
  1256. C    TOOLPACK/1    Release: 2.5
  1257. C---------------------------------------------------------
  1258.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1259.         INTEGER ROOT,TREE(4,46339),TRETOP
  1260.  
  1261.         SAVE /XCTREE/
  1262. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1263.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1264.  
  1265.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1266.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1267.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1268.         DOWN(JABC12)=TREE(2,JABC12)
  1269.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1270.         NATTR(JABC12)=TREE(4,JABC12)
  1271.  
  1272. C
  1273. C Output header
  1274. C
  1275.         CALL ZPTINT(ROOT,1,IOD)
  1276.         CALL PUTCH(32,IOD)
  1277.         CALL ZPTINT(TRETOP,1,IOD)
  1278.         CALL PUTCH(10,IOD)
  1279. C
  1280. C Output tree
  1281. C
  1282.         DO 100 I=1,TRETOP
  1283.             CALL ZPTINT(NTYPE(I),1,IOD)
  1284.             CALL PUTCH(32,IOD)
  1285.             CALL ZPTINT(DOWN(I),1,IOD)
  1286.             CALL PUTCH(32,IOD)
  1287.             CALL ZPTINT(NEXT(I),1,IOD)
  1288.             CALL PUTCH(32,IOD)
  1289.             CALL ZPTINT(PREV(I),1,IOD)
  1290.             CALL PUTCH(32,IOD)
  1291.             CALL ZPTINT(UP(I),1,IOD)
  1292.             CALL PUTCH(32,IOD)
  1293.             CALL ZPTINT(NATTR(I),1,IOD)
  1294.             IF (MOD(I,3).EQ.0) THEN
  1295.                 CALL PUTCH(10,IOD)
  1296.             ELSE
  1297.                 CALL PUTCH(32,IOD)
  1298.             END IF
  1299.  100    CONTINUE
  1300.         IF (MOD(TRETOP,3).NE.0) CALL PUTCH(10,IOD)
  1301.         CALL CLOSE(IOD)
  1302.  
  1303.         END
  1304. C ----------------------------------------------------------------------
  1305. C
  1306. C       Z Y S O U T   -   Output symbol table (and strings)
  1307. C
  1308.  
  1309.         SUBROUTINE ZYSOUT(IOD)
  1310.         INTEGER IOD
  1311.  
  1312. C---------------------------------------------------------
  1313. C    TOOLPACK/1    Release: 2.5
  1314. C---------------------------------------------------------
  1315.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1316.         INTEGER NSYMS,NPUS,PUIDX(250),
  1317.      +          SYMBOL(8,5003)
  1318.         LOGICAL MODFLG
  1319.  
  1320.         SAVE /XCSYMS/
  1321. C---------------------------------------------------------
  1322. C    TOOLPACK/1    Release: 2.5
  1323. C---------------------------------------------------------
  1324.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  1325.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  1326.  
  1327.         SAVE /XCSTRI/
  1328.  
  1329.  
  1330.         INTEGER BUFF(134),BPNTR,SPNTR,I,J
  1331.  
  1332.         EXTERNAL PUTLIN,ZPTINT,PUTCH,CLOSE,ZMESS
  1333.  
  1334. C
  1335. C Write out the string table to the front of the symbol table file
  1336. C
  1337.  
  1338.         CALL ZPTINT(NSTRNG,1,IOD)
  1339.         CALL PUTCH(32,IOD)
  1340.         CALL ZPTINT(TXTTOP,1,IOD)
  1341.         CALL PUTCH(10,IOD)
  1342.         BPNTR=0
  1343.         DO 100 SPNTR=1,TXTTOP-1
  1344.             BPNTR=BPNTR+1
  1345.  
  1346.             IF (STRTXT(SPNTR).EQ.129) THEN
  1347.                 BUFF(BPNTR)=39
  1348.             ELSE IF (STRTXT(SPNTR).EQ.39) THEN
  1349.                 BUFF(BPNTR)=47
  1350.             ELSE
  1351.                 BUFF(BPNTR)=STRTXT(SPNTR)
  1352.             END IF
  1353.             IF (BPNTR.EQ.132) THEN
  1354.                 BUFF(BPNTR+1)=10
  1355.                 BUFF(BPNTR+2)=129
  1356.                 CALL PUTLIN(BUFF,IOD)
  1357.                 BPNTR=0
  1358.             END IF
  1359.             IF (STRTXT(SPNTR).EQ.39 .OR. STRTXT(SPNTR).EQ.47)
  1360.      +      THEN
  1361.                 BPNTR=BPNTR+1
  1362.                 BUFF(BPNTR)=STRTXT(SPNTR)
  1363.                 IF (BPNTR.EQ.132) THEN
  1364.                     BUFF(BPNTR+1)=10
  1365.                     BUFF(BPNTR+2)=129
  1366.                     CALL PUTLIN(BUFF,IOD)
  1367.                     BPNTR=0
  1368.                 END IF
  1369.             END IF
  1370.  100    CONTINUE
  1371.         IF (BPNTR.GT.0) THEN
  1372.             BUFF(BPNTR+1)=10
  1373.             BUFF(BPNTR+2)=129
  1374.             CALL PUTLIN(BUFF,IOD)
  1375.         END IF
  1376. C
  1377. C Write the symbol table following the strings
  1378. C
  1379.  
  1380.         CALL ZPTINT(NSYMS,1,IOD)
  1381.         CALL PUTCH(32,IOD)
  1382.         CALL ZPTINT(NPUS,1,IOD)
  1383.         CALL PUTCH(32,IOD)
  1384.         CALL ZPTINT(250,1,IOD)
  1385.         CALL PUTCH(32,IOD)
  1386.         IF (MODFLG) THEN
  1387.             CALL ZMESS('1',IOD)
  1388.         ELSE
  1389.             CALL ZMESS('0',IOD)
  1390.         END IF
  1391.         DO 300 I=1,NSYMS
  1392.             DO 200 J=1,8
  1393.                 CALL ZPTINT(SYMBOL(J,I),1,IOD)
  1394.                 CALL PUTCH(32,IOD)
  1395.  200        CONTINUE
  1396.             IF (MOD(I,2).EQ.0) CALL PUTCH(10,IOD)
  1397.  300    CONTINUE
  1398.         IF (MOD(NSYMS,2).NE.0) CALL PUTCH(10,IOD)
  1399. C
  1400. C Write the program-unit index following the symbol table proper
  1401. C
  1402.         DO 400 I=1,MIN(250,NPUS)
  1403.             CALL ZPTINT(PUIDX(I),1,IOD)
  1404.             CALL PUTCH(32,IOD)
  1405.             IF (MOD(I,22).EQ.0) CALL PUTCH(10,IOD)
  1406.  400    CONTINUE
  1407.         CALL PUTCH(10,IOD)
  1408. C
  1409. C Finished
  1410. C
  1411.         CALL CLOSE(IOD)
  1412.  
  1413.         END
  1414. C ----------------------------------------------------------------------
  1415. C
  1416. C       Z Y U P   -   Return up pointer of a node
  1417. C
  1418.  
  1419.         INTEGER FUNCTION ZYUP(NODE)
  1420.         INTEGER NODE
  1421.  
  1422. C---------------------------------------------------------
  1423. C    TOOLPACK/1    Release: 2.5
  1424. C---------------------------------------------------------
  1425.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1426.         INTEGER ROOT,TREE(4,46339),TRETOP
  1427.  
  1428.         SAVE /XCTREE/
  1429.  
  1430.         ZYUP=TREE(1,NODE)/46340
  1431.  
  1432.         END
  1433. C ----------------------------------------------------------------------
  1434. C
  1435. C       Z Y N N A M   -   Return node name as a character string
  1436. C
  1437.  
  1438.         CHARACTER*11 FUNCTION ZYNNAM(NUMBER)
  1439.         INTEGER NUMBER
  1440.  
  1441.         CHARACTER*11 NNAMES(0:132)
  1442.  
  1443.         DATA NNAMES/'ERROR','ROOT','MAIN','F_SUBP','S_SUBP',
  1444.      +'BD_SUBP','END','PROGRAM','FUNCTION','INTEGER','REAL','DOUBLE',
  1445.      +'COMPLEX','LOGICAL','CHARACTER','LIST','SUBROUTINE','ASTERISK',
  1446.      +'ENTRY','BLOCK_DATA','DIMENSION','ARR_DECLR','ARDIM','DARDIM',
  1447.      +'EQUIVALENCE','EQVSET','COMMON','BLNKCM','LBLDCM','CBITEMS',
  1448.      +'TYPE','CHAR_LEN','IMPLICIT','IMPL_DECL','CHAR_RANGE','PARAMETER',
  1449.      +'PARAM DECL','EXTERNAL','INTRINSIC','SAVE','CBLK NAME','DATA',
  1450.      +'DATA_DECL','DATA_ITEMS','DATA_VALS','MULT_VAL','NEG',
  1451.      +'DATA_IMPDO','DOSPEC','ASGN','ASSIGN','GOTO','CMGOTO','ASGOTO',
  1452.      +'LABELLIST','ARITHIF','LOG_IF','BLOCKIF','ELSEIF','ELSE','ENDIF',
  1453.      +'DO','CONTINUE','STOP','PAUSE','WRITE','READ','PRINT','CILIST',
  1454.      +'CIITEM','CONCAT','IOIMDL','OPEN','CLOSE','INQUIRE','BACKSPACE',
  1455.      +'ENDFILE','REWIND','FORMAT','REPEAT','SLASH','COLON','CALL',
  1456.      +'RETURN','.EQV.','.NEQV.','.OR.','.AND.','.NOT.','.LT.','.LE.',
  1457.      +'.EQ.','.NE.','.GT.','.GE.','PLUS','MINUS','POS','MULTIPLY',
  1458.      +'DIVIDE','EXPONT','SPAREN','CCONST','SUBSTR','ARELM','SSSPEC',
  1459.      +'DEFAULT','ICONST','NAME','LCONST','RCONST','DPCONST','FMTFLD',
  1460.      +'HCONST','SCONST','LABEL','LABELREF','SUBFMT','IOKW','FUNREF',
  1461.      +'IMPCHAR','STMT_FN','UNIT=','FMT=','AMBIGUOUS','DCMPLX','SCALE',
  1462.      +'INCL_EQUIV','INCL_DATA','INCL_COMM','INCL_SAVE','COMMENT','DMY'/
  1463.  
  1464.         IF (NUMBER.GE.0 .AND. NUMBER.LE.132) THEN
  1465.             ZYNNAM=NNAMES(NUMBER)
  1466.         ELSE
  1467.             ZYNNAM='Invalid arg'
  1468.         END IF
  1469.  
  1470.         END
  1471. C ----------------------------------------------------------------------
  1472. C
  1473. C       Z Y S E R R   -   Signal a symbol error (possibly fatal)
  1474. C
  1475.  
  1476.         SUBROUTINE ZYSERR(ERRMSG,SYMPTR,FATAL)
  1477.         CHARACTER*(*) ERRMSG
  1478.         INTEGER SYMPTR
  1479.         LOGICAL FATAL
  1480.  
  1481. C---------------------------------------------------------
  1482. C    TOOLPACK/1    Release: 2.5
  1483. C---------------------------------------------------------
  1484.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1485.         INTEGER NSYMS,NPUS,PUIDX(250),
  1486.      +          SYMBOL(8,5003)
  1487.         LOGICAL MODFLG
  1488.  
  1489.         SAVE /XCSYMS/
  1490. C---------------------------------------------------------
  1491. C    TOOLPACK/1    Release: 2.5
  1492. C---------------------------------------------------------
  1493.         COMMON/XCSTRI/STRTXT,STRTBL,NSTRNG,TXTTOP
  1494.         INTEGER STRTXT(46339),STRTBL(7103),NSTRNG,TXTTOP
  1495.  
  1496.         SAVE /XCSTRI/
  1497.  
  1498.  
  1499.         EXTERNAL ZCHOUT,PUTLIN,PUTCH,ERROR
  1500.  
  1501.         CALL ZCHOUT(ERRMSG,2)
  1502.         CALL ZCHOUT(' - ',2)
  1503.         CALL PUTLIN(STRTXT(SYMBOL(2,SYMPTR)),2)
  1504.         CALL PUTCH(10,2)
  1505.         IF (FATAL) CALL ERROR('Fatal Error: Program Aborted')
  1506.  
  1507.         END
  1508. C ----------------------------------------------------------------------
  1509. C
  1510. C       Z Y A D S N   -   Add a subnode (becomes the last subnode)
  1511. C
  1512.  
  1513.         SUBROUTINE ZYADSN(NODE,SUB)
  1514.         INTEGER NODE,SUB
  1515.  
  1516. C---------------------------------------------------------
  1517. C    TOOLPACK/1    Release: 2.5
  1518. C---------------------------------------------------------
  1519. C
  1520. C Common block and access functions for YP parse tree
  1521. C
  1522. C---------------------------------------------------------
  1523. C    TOOLPACK/1    Release: 2.5
  1524. C---------------------------------------------------------
  1525.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1526.         INTEGER ROOT,TREE(4,46339),TRETOP
  1527.  
  1528.         SAVE /XCTREE/
  1529. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1530.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1531.  
  1532.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1533.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1534.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1535.         DOWN(JABC12)=TREE(2,JABC12)
  1536.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1537.         NATTR(JABC12)=TREE(4,JABC12)
  1538.  
  1539.         IF (UP(SUB).NE.0) CALL ZYDELT(SUB)
  1540.         IF (DOWN(NODE).GT.0) THEN
  1541.             CALL ZYADNX(SUB,PREV(DOWN(NODE)))
  1542.         ELSE
  1543.             TREE(1,SUB)=MOD(TREE(1,SUB),46340)+46340*NODE
  1544.             CALL ZYCHDN(NODE,SUB)
  1545.         END IF
  1546.  
  1547.         END
  1548. C ----------------------------------------------------------------------
  1549. C
  1550. C       Z Y G P U S   -   Get Program-Unit Symbol pointer
  1551. C
  1552.  
  1553.         INTEGER FUNCTION ZYGPUS(PUN)
  1554.         INTEGER PUN
  1555.  
  1556. C---------------------------------------------------------
  1557. C    TOOLPACK/1    Release: 2.5
  1558. C---------------------------------------------------------
  1559.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1560.         INTEGER NSYMS,NPUS,PUIDX(250),
  1561.      +          SYMBOL(8,5003)
  1562.         LOGICAL MODFLG
  1563.  
  1564.         SAVE /XCSYMS/
  1565.  
  1566.         IF (PUN.GT.NPUS) THEN
  1567.             ZYGPUS=-100
  1568.         ELSE
  1569.             ZYGPUS=PUIDX(MIN(PUN,22))
  1570.  100        IF (SYMBOL(3,ZYGPUS).NE.PUN .OR.
  1571.      +          SYMBOL(1,ZYGPUS).NE.4) THEN
  1572.                 ZYGPUS=ZYGPUS+1
  1573.                 GOTO 100
  1574.             END IF
  1575.         END IF
  1576.  
  1577.         END
  1578. C ----------------------------------------------------------------------
  1579. C
  1580. C       Z Y P U S Y   -   Like ZYGPUS, but from program-unit root node
  1581. C
  1582.  
  1583.         INTEGER FUNCTION ZYPUSY(PUROOT)
  1584.         INTEGER PUROOT
  1585.  
  1586.         INTEGER PTR,PUNUM
  1587.  
  1588.         INTEGER ZYGPUS
  1589.  
  1590. C---------------------------------------------------------
  1591. C    TOOLPACK/1    Release: 2.5
  1592. C---------------------------------------------------------
  1593. C
  1594. C Common block and access functions for YP parse tree
  1595. C
  1596. C---------------------------------------------------------
  1597. C    TOOLPACK/1    Release: 2.5
  1598. C---------------------------------------------------------
  1599.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1600.         INTEGER ROOT,TREE(4,46339),TRETOP
  1601.  
  1602.         SAVE /XCTREE/
  1603. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1604.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1605.  
  1606.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1607.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1608.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1609.         DOWN(JABC12)=TREE(2,JABC12)
  1610.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1611.         NATTR(JABC12)=TREE(4,JABC12)
  1612.  
  1613.         PTR=DOWN(PUROOT)
  1614.         IF (NTYPE(PTR).EQ.7 .OR.
  1615.      +      NTYPE(PTR).EQ.16 .OR.
  1616.      +      NTYPE(PTR).EQ.8 .OR.
  1617.      +      NTYPE(PTR).EQ.19 .AND. DOWN(PTR).NE.0) THEN
  1618.             PTR=DOWN(PTR)
  1619.             IF (NTYPE(PTR).NE.108) PTR=NEXT(PTR)
  1620.             IF (NTYPE(PTR).NE.108) PTR=NEXT(PTR)
  1621.             ZYPUSY=-DOWN(PTR)
  1622.         ELSE
  1623.             PTR=DOWN(UP(PUROOT))
  1624.             PUNUM=1
  1625.  100        IF (PTR.NE.PUROOT) THEN
  1626.                 PTR=NEXT(PTR)
  1627.                 GOTO 100
  1628.             END IF
  1629.             ZYPUSY=ZYGPUS(PUNUM)
  1630.         END IF
  1631.  
  1632.         END
  1633. C ----------------------------------------------------------------------
  1634. C
  1635. C       Z Y C S D T   -   Canonicalise Symbol Data Types
  1636. C
  1637.  
  1638.         SUBROUTINE ZYCSDT(CAFORM,ALL)
  1639.         INTEGER CAFORM
  1640.         LOGICAL ALL
  1641.  
  1642. C---------------------------------------------------------
  1643. C    TOOLPACK/1    Release: 2.5
  1644. C---------------------------------------------------------
  1645.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1646.         INTEGER NSYMS,NPUS,PUIDX(250),
  1647.      +          SYMBOL(8,5003)
  1648.         LOGICAL MODFLG
  1649.  
  1650.         SAVE /XCSYMS/
  1651.  
  1652.         INTEGER I
  1653.  
  1654.         DO 100 I=1,NSYMS
  1655.             IF (SYMBOL(1,I).GE.3) THEN
  1656.                 IF (SYMBOL(4,I).EQ.2) THEN
  1657.  
  1658. C REAL --> REAL*4 [if "lenspecs"]
  1659.  
  1660.                     IF (CAFORM.EQ.2 .AND.
  1661.      +                  SYMBOL(5,I).EQ.0)
  1662.      +                  SYMBOL(5,I)=4
  1663.  
  1664. C REAL*4 --> REAL [unless "lenspecs"]
  1665.  
  1666.                     IF (CAFORM.NE.2) THEN
  1667.                         IF (SYMBOL(5,I).EQ.4)
  1668.      +                      SYMBOL(5,I)=0
  1669.  
  1670. C REAL*8 --> DOUBLE PRECISION [unless "lenspecs"]
  1671.  
  1672.                         IF (SYMBOL(5,I).EQ.2*4) THEN
  1673.                             SYMBOL(4,I)=5
  1674.                             SYMBOL(5,I)=0
  1675.                         END IF
  1676.                     END IF
  1677.                 ELSE IF (SYMBOL(4,I).EQ.4) THEN
  1678.  
  1679. C COMPLEX --> COMPLEX*8 [if "lenspecs"]
  1680.  
  1681.                     IF (CAFORM.EQ.2 .AND.
  1682.      +                  SYMBOL(5,I).EQ.0)
  1683.      +                  SYMBOL(5,I)=2*4
  1684.  
  1685. C COMPLEX*8 --> COMPLEX [unless "lenspecs"]
  1686.  
  1687.                     IF (CAFORM.NE.2 .AND.
  1688.      +                  SYMBOL(5,I).EQ.2*4)
  1689.      +                  SYMBOL(5,I)=0
  1690.  
  1691. C COMPLEX*16 --> DOUBLE COMPLEX [if "keywords"]
  1692.  
  1693.                     IF (CAFORM.EQ.1 .AND.
  1694.      +                  SYMBOL(5,I).EQ.4*4) THEN
  1695.                         SYMBOL(4,I)=7
  1696.                         SYMBOL(5,I)=0
  1697.                     END IF
  1698.  
  1699. C DOUBLE PRECISION --> REAL*8 [if "lenspecs"]
  1700.  
  1701.                 ELSE IF (SYMBOL(4,I).EQ.5 .AND.
  1702.      +                   CAFORM.EQ.2) THEN
  1703.                     SYMBOL(4,I)=2
  1704.                     SYMBOL(5,I)=2*4
  1705.  
  1706. C DOUBLE COMPLEX --> COMPLEX*16 [unless "keywords"]
  1707.  
  1708.                 ELSE IF (SYMBOL(4,I).EQ.7 .AND.
  1709.      +                   CAFORM.NE.1) THEN
  1710.                     SYMBOL(4,I)=4
  1711.                     SYMBOL(5,I)=4*4
  1712.                 ELSE IF (ALL) THEN
  1713.  
  1714. C *** Only do following transformations if "ALL" specified ***
  1715.  
  1716.                     IF (SYMBOL(4,I).EQ.1) THEN
  1717.  
  1718. C INTEGER --> INTEGER*4 [if "lenspecs"]
  1719.  
  1720.                         IF (CAFORM.EQ.2) THEN
  1721.                             IF (SYMBOL(5,I).EQ.0)
  1722.      +                          SYMBOL(5,I)=4
  1723.                         ELSE
  1724.  
  1725. C INTEGER*4 --> INTEGER [unless "lenspecs"]
  1726.  
  1727.                             IF (SYMBOL(5,I).EQ.4)
  1728.      +                          SYMBOL(5,I)=0
  1729.                         END IF
  1730.                     ELSE IF (SYMBOL(4,I).EQ.3) THEN
  1731.  
  1732. C LOGICAL --> LOGICAL*4 [if "lenspecs"]
  1733.  
  1734.                         IF (CAFORM.EQ.2) THEN
  1735.                             IF (SYMBOL(5,I).EQ.0)
  1736.      +                          SYMBOL(5,I)=4
  1737.                         ELSE
  1738.  
  1739. C LOGICAL*4 --> LOGICAL [unless "lenspecs"]
  1740.  
  1741.                             IF (SYMBOL(5,I).EQ.4)
  1742.      +                          SYMBOL(5,I)=0
  1743.                         END IF
  1744.                     ELSE IF (SYMBOL(4,I).EQ.6) THEN
  1745.  
  1746. C CHARACTER --> CHARACTER*1 [if "lenspecs"]
  1747.  
  1748.                         IF (CAFORM.EQ.2) THEN
  1749.                             IF (SYMBOL(5,I).EQ.0)
  1750.      +                          SYMBOL(5,I)=1
  1751.                         ELSE
  1752.  
  1753. C CHARACTER*1 --> CHARACTER [unless "lenspecs"]
  1754.  
  1755.                             IF (SYMBOL(5,I).EQ.1)
  1756.      +                          SYMBOL(5,I)=0
  1757.                         END IF
  1758.                     END IF
  1759.                 END IF
  1760.             END IF
  1761.  100    CONTINUE
  1762.  
  1763.         END
  1764. C ----------------------------------------------------------------------
  1765. C
  1766. C       Z Y C A D T   -   Return a canonical data type
  1767. C
  1768. C       For REAL*n, INTEGER*n, LOGICAL*n, COMPLEX*n, this returns the
  1769. C       single-value datatype code (used by ISTSA).
  1770. C
  1771. C       The value 0 (which is not a legal data type) is returned if the
  1772. C       DTYPE/CHRLEN combination is not legal.
  1773. C
  1774. C       "type_char" is returned for all CHARACTER types (the length is
  1775. C       ignored.
  1776. C
  1777.  
  1778.         INTEGER FUNCTION ZYCADT(DTYPE,CHRLEN)
  1779.         INTEGER DTYPE,CHRLEN
  1780.  
  1781.         ZYCADT=0
  1782.         IF (DTYPE.EQ.6 .OR. CHRLEN.EQ.0) THEN
  1783.             ZYCADT=DTYPE
  1784.         ELSE IF (DTYPE.EQ.2) THEN
  1785.             IF (CHRLEN.EQ.4) THEN
  1786.                 ZYCADT=2
  1787.             ELSE IF (CHRLEN.EQ.2*4) THEN
  1788.                 ZYCADT=5
  1789.             ELSE IF (CHRLEN.EQ.4*4) THEN
  1790.                 ZYCADT=15
  1791.             END IF
  1792.         ELSE IF (DTYPE.EQ.1) THEN
  1793.             IF (2*CHRLEN.EQ.4) THEN
  1794.                 ZYCADT=14
  1795.             ELSE IF (CHRLEN.EQ.4) THEN
  1796.                 ZYCADT=1
  1797.             END IF
  1798.         ELSE IF (DTYPE.EQ.3) THEN
  1799.             IF (4*CHRLEN.EQ.4) THEN
  1800.                 ZYCADT=12
  1801.             ELSE IF (2*CHRLEN.EQ.4) THEN
  1802.                 ZYCADT=13
  1803.             ELSE IF (CHRLEN.EQ.4) THEN
  1804.                 ZYCADT=3
  1805.             END IF
  1806.         ELSE IF (DTYPE.EQ.4) THEN
  1807.             IF (CHRLEN.EQ.2*4) THEN
  1808.                 ZYCADT=4
  1809.             ELSE IF (CHRLEN.EQ.4*4) THEN
  1810.                 ZYCADT=7
  1811.             END IF
  1812.         END IF
  1813.  
  1814.         END
  1815. C ----------------------------------------------------------------------
  1816. C
  1817. C       Z Y F D U P   -   Find duplicate symbol name (of common)
  1818. C
  1819.  
  1820.         INTEGER FUNCTION ZYFDUP(COMPTR)
  1821.         INTEGER COMPTR
  1822.  
  1823. C---------------------------------------------------------
  1824. C    TOOLPACK/1    Release: 2.5
  1825. C---------------------------------------------------------
  1826.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1827.         INTEGER NSYMS,NPUS,PUIDX(250),
  1828.      +          SYMBOL(8,5003)
  1829.         LOGICAL MODFLG
  1830.  
  1831.         SAVE /XCSYMS/
  1832.  
  1833.         EXTERNAL ERROR
  1834.  
  1835.         IF (COMPTR.LT.1 .OR. COMPTR.GT.NSYMS)
  1836.      +      CALL ERROR('ZYFDUP: Invalid argument')
  1837.         ZYFDUP=PUIDX(MIN(SYMBOL(3,COMPTR),22))
  1838.  100    IF (SYMBOL(3,ZYFDUP).NE.SYMBOL(3,COMPTR)) THEN
  1839.             ZYFDUP=ZYFDUP+1
  1840.             GOTO 100
  1841.         END IF
  1842.  200    IF (SYMBOL(3,ZYFDUP).EQ.SYMBOL(3,COMPTR) .AND.
  1843.      +      SYMBOL(2,ZYFDUP).EQ.SYMBOL(2,COMPTR) .AND.
  1844.      +      ZYFDUP.NE.COMPTR) RETURN
  1845.         ZYFDUP=ZYFDUP+1
  1846.         IF (ZYFDUP.LE.NSYMS .AND. (MODFLG .OR.
  1847.      +      SYMBOL(3,ZYFDUP-1).EQ.SYMBOL(3,COMPTR)))
  1848.      +      GOTO 200
  1849.         ZYFDUP=0
  1850.  
  1851.         END
  1852. C ----------------------------------------------------------------------
  1853. C
  1854. C       Z Y G E N L   -   Generate a label, unique within a program unit
  1855. C
  1856.  
  1857.         INTEGER FUNCTION ZYGENL(LABNUM,PUN)
  1858.         INTEGER LABNUM,PUN
  1859.  
  1860.         INTEGER RESULT(8),TEXT(6)
  1861.  
  1862.         INTRINSIC MOD
  1863.  
  1864.         INTEGER ZYFSYM,ITOC,ZYASTR,ZYASYM
  1865.         EXTERNAL ZYFSYM,ITOC,ZYASTR,ZYASYM
  1866.  
  1867.  100    LABNUM=MOD(LABNUM,99999)+1
  1868.         ZYGENL=ITOC(LABNUM,TEXT,6)
  1869.         ZYGENL=ZYFSYM(TEXT,PUN,RESULT)
  1870.         IF (ZYGENL.NE.-1) GOTO 100
  1871.         ZYGENL=ZYASYM(ZYASTR(TEXT),PUN,1)
  1872.  
  1873.         END
  1874. C ----------------------------------------------------------------------
  1875. C
  1876. C       Z Y S T X F    -   SeT eXtended Field
  1877. C
  1878.  
  1879.         SUBROUTINE ZYSTXF(NODE,XVALUE)
  1880.         INTEGER NODE,XVALUE
  1881.  
  1882. C---------------------------------------------------------
  1883. C    TOOLPACK/1    Release: 2.5
  1884. C---------------------------------------------------------
  1885.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1886.         INTEGER ROOT,TREE(4,46339),TRETOP
  1887.  
  1888.         SAVE /XCTREE/
  1889.  
  1890.         TREE(4,NODE)=XVALUE
  1891.  
  1892.         END
  1893. C ----------------------------------------------------------------------
  1894. C
  1895. C       Z Y G T X F   -   GeT eXtended Field
  1896. C
  1897.  
  1898.         INTEGER FUNCTION ZYGTXF(NODE)
  1899.         INTEGER NODE
  1900.  
  1901. C---------------------------------------------------------
  1902. C    TOOLPACK/1    Release: 2.5
  1903. C---------------------------------------------------------
  1904. C
  1905. C Common block and access functions for YP parse tree
  1906. C
  1907. C---------------------------------------------------------
  1908. C    TOOLPACK/1    Release: 2.5
  1909. C---------------------------------------------------------
  1910.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1911.         INTEGER ROOT,TREE(4,46339),TRETOP
  1912.  
  1913.         SAVE /XCTREE/
  1914. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1915.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1916.  
  1917.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1918.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1919.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1920.         DOWN(JABC12)=TREE(2,JABC12)
  1921.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1922.         NATTR(JABC12)=TREE(4,JABC12)
  1923.  
  1924.         ZYGTXF=NATTR(NODE)
  1925.  
  1926.         END
  1927. C ----------------------------------------------------------------------
  1928. C
  1929. C       Z Y J M P A   -   Return a jump address (parse tree node number)
  1930. C                         from the label node referencing it.
  1931. C
  1932.  
  1933.         INTEGER FUNCTION ZYJMPA(NODE)
  1934.         INTEGER NODE
  1935.  
  1936. C---------------------------------------------------------
  1937. C    TOOLPACK/1    Release: 2.5
  1938. C---------------------------------------------------------
  1939.         COMMON/XCSYMS/MODFLG,NSYMS,NPUS,PUIDX,SYMBOL
  1940.         INTEGER NSYMS,NPUS,PUIDX(250),
  1941.      +          SYMBOL(8,5003)
  1942.         LOGICAL MODFLG
  1943.  
  1944.         SAVE /XCSYMS/
  1945.  
  1946.         EXTERNAL ERROR
  1947.  
  1948. C---------------------------------------------------------
  1949. C    TOOLPACK/1    Release: 2.5
  1950. C---------------------------------------------------------
  1951. C
  1952. C Common block and access functions for YP parse tree
  1953. C
  1954. C---------------------------------------------------------
  1955. C    TOOLPACK/1    Release: 2.5
  1956. C---------------------------------------------------------
  1957.         COMMON/XCTREE/ROOT,TREE,TRETOP
  1958.         INTEGER ROOT,TREE(4,46339),TRETOP
  1959.  
  1960.         SAVE /XCTREE/
  1961. C Use "JABC12" to try to avoid conflicts with ordinary variables
  1962.         INTEGER NEXT,PREV,UP,DOWN,NATTR,NTYPE,JABC12
  1963.  
  1964.         NEXT(JABC12)=MOD(TREE(3,JABC12),46340)
  1965.         PREV(JABC12)=(TREE(3,JABC12)/46340)
  1966.         UP(JABC12)=(TREE(1,JABC12)/46340)
  1967.         DOWN(JABC12)=TREE(2,JABC12)
  1968.         NTYPE(JABC12)=MOD(TREE(1,JABC12),46340)
  1969.         NATTR(JABC12)=TREE(4,JABC12)
  1970.  
  1971.         IF (NTYPE(NODE).NE.116)
  1972.      +      CALL ERROR('INTERNAL ERROR: INVALID ARGUMENT TO ZYJMPA')
  1973.         ZYJMPA=SYMBOL(4,-DOWN(NODE))
  1974.  
  1975.         END
  1976.